home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / synclo < prev    next >
Text File  |  1992-11-07  |  24KB  |  750 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; This material was developed by the Scheme project at the
  6. ;;; Massachusetts Institute of Technology, Department of Electrical
  7. ;;; Engineering and Computer Science.  Permission to copy this
  8. ;;; software, to redistribute it, and to use it for any purpose is
  9. ;;; granted, subject to the following restrictions and understandings.
  10. ;;;
  11. ;;; 1. Any copy made of this software must include this copyright
  12. ;;; notice in full.
  13. ;;;
  14. ;;; 2. Users of this software agree to make their best efforts (a) to
  15. ;;; return to the MIT Scheme project any improvements or extensions
  16. ;;; that they make, so that these may be included in future releases;
  17. ;;; and (b) to inform MIT of noteworthy uses of this software.
  18. ;;;
  19. ;;; 3. All materials developed as a consequence of the use of this
  20. ;;; software shall duly acknowledge such use, in accordance with the
  21. ;;; usual standards of acknowledging credit in academic research.
  22. ;;;
  23. ;;; 4. MIT has made no warrantee or representation that the operation
  24. ;;; of this software will be error-free, and MIT is under no
  25. ;;; obligation to provide any services, by way of maintenance, update,
  26. ;;; or otherwise.
  27. ;;;
  28. ;;; 5. In conjunction with products arising from the use of this
  29. ;;; material, there shall be no use of the name of the Massachusetts
  30. ;;; Institute of Technology nor of any adaptation thereof in any
  31. ;;; advertising, promotional, or sales literature without prior
  32. ;;; written consent from MIT in each case.
  33.  
  34. ;;;; Syntactic Closures
  35. ;;; written by Alan Bawden
  36. ;;; extensively modified by Chris Hanson
  37.  
  38. ;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
  39. ;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
  40. ;;; Programming, page 86.
  41.  
  42. ;;;; Classifier
  43. ;;;  The classifier maps forms into items.  In addition to locating
  44. ;;;  definitions so that they can be properly processed, it also
  45. ;;;  identifies keywords and variables, which allows a powerful form
  46. ;;;  of syntactic binding to be implemented.
  47.  
  48. (define (classify/form form environment definition-environment)
  49.   (cond ((identifier? form)
  50.      (syntactic-environment/lookup environment form))
  51.     ((syntactic-closure? form)
  52.      (let ((form (syntactic-closure/form form))
  53.            (environment
  54.         (filter-syntactic-environment
  55.          (syntactic-closure/free-names form)
  56.          environment
  57.          (syntactic-closure/environment form))))
  58.        (classify/form form
  59.               environment
  60.               definition-environment)))
  61.     ((pair? form)
  62.      (let ((item
  63.         (classify/subexpression (car form) environment)))
  64.        (cond ((keyword-item? item)
  65.           ((keyword-item/classifier item) form
  66.                           environment
  67.                           definition-environment))
  68.          ((list? (cdr form))
  69.           (let ((items
  70.              (classify/subexpressions (cdr form)
  71.                           environment)))
  72.             (make-expression-item
  73.              (lambda ()
  74.                (output/combination
  75.             (compile-item/expression item)
  76.             (map compile-item/expression items)))
  77.              form)))
  78.          (else
  79.           (syntax-error "combination must be a proper list"
  80.                 form)))))
  81.     (else
  82.      (make-expression-item ;don't quote literals evaluating to themselves
  83.        (if (or (boolean? form) (char? form) (number? form) (string? form))
  84.            (lambda () (output/literal-unquoted form))
  85.            (lambda () (output/literal-quoted form))) form))))
  86.  
  87. (define (classify/subform form environment definition-environment)
  88.   (classify/form form
  89.          environment
  90.          definition-environment))
  91.  
  92. (define (classify/subforms forms environment definition-environment)
  93.   (map (lambda (form)
  94.      (classify/subform form environment definition-environment))
  95.        forms))
  96.  
  97. (define (classify/subexpression expression environment)
  98.   (classify/subform expression environment environment))
  99.  
  100. (define (classify/subexpressions expressions environment)
  101.   (classify/subforms expressions environment environment))
  102.  
  103. ;;;; Compiler
  104. ;;;  The compiler maps items into the output language.
  105.  
  106. (define (compile-item/expression item)
  107.   (let ((illegal
  108.      (lambda (item name)
  109.        (let ((decompiled (decompile-item item))) (newline)
  110.        (slib:error (string-append name
  111.                     " may not be used as an expression")
  112.              decompiled)))))
  113.     (cond ((variable-item? item)
  114.        (output/variable (variable-item/name item)))
  115.       ((expression-item? item)
  116.        ((expression-item/compiler item)))
  117.       ((body-item? item)
  118.        (let ((items (flatten-body-items (body-item/components item))))
  119.          (if (null? items)
  120.          (illegal item "empty sequence")
  121.          (output/sequence (map compile-item/expression items)))))
  122.       ((definition-item? item)
  123.        (let ((binding ;allows later scheme errors, but allows top-level
  124.           (bind-definition-item! ;(if (not (defined? x)) define it)
  125.            scheme-syntactic-environment item))) ;as in Init.scm
  126.          (output/top-level-definition
  127.           (car binding)
  128.           (compile-item/expression (cdr binding)))))
  129.       ((keyword-item? item)
  130.        (illegal item "keyword"))
  131.       (else
  132.        (impl-error "unknown item" item)))))
  133.  
  134. (define (compile/subexpression expression environment)
  135.   (compile-item/expression
  136.    (classify/subexpression expression environment)))
  137.  
  138. (define (compile/top-level forms environment)
  139.   ;; Top-level syntactic definitions affect all forms that appear
  140.   ;; after them.
  141.   (output/top-level-sequence
  142.    (let forms-loop ((forms forms))
  143.      (if (null? forms)
  144.      '()
  145.      (let items-loop
  146.          ((items
  147.            (item->list
  148.         (classify/subform (car forms)
  149.                   environment
  150.                   environment))))
  151.        (cond ((null? items)
  152.           (forms-loop (cdr forms)))
  153.          ((definition-item? (car items))
  154.           (let ((binding
  155.              (bind-definition-item! environment (car items))))
  156.             (if binding
  157.             (cons (output/top-level-definition
  158.                    (car binding)
  159.                    (compile-item/expression (cdr binding)))
  160.                   (items-loop (cdr items)))
  161.             (items-loop (cdr items)))))
  162.          (else
  163.           (cons (compile-item/expression (car items))
  164.             (items-loop (cdr items))))))))))
  165.  
  166. ;;;; De-Compiler
  167. ;;;  The de-compiler maps partly-compiled things back to the input language,
  168. ;;;  as far as possible.  Used to display more meaningful macro error messages.
  169.  
  170. (define (decompile-item item)
  171.     (display " ")
  172.     (cond ((variable-item? item) (variable-item/name item))
  173.       ((expression-item? item)
  174.        (decompile-item (expression-item/annotation item)))
  175.       ((body-item? item)
  176.        (let ((items (flatten-body-items (body-item/components item))))
  177.          (display "sequence")
  178.          (if (null? items)
  179.          "empty sequence"
  180.          "non-empty sequence")))
  181.       ((definition-item? item) "definition")
  182.       ((keyword-item? item)
  183.        (decompile-item (keyword-item/name item)));in case expression
  184.       ((syntactic-closure? item); (display "syntactic-closure;")
  185.        (decompile-item (syntactic-closure/form item)))
  186.       ((list? item) (display "(")
  187.         (map decompile-item item) (display ")") "see list above")
  188.       ((string? item) item);explicit name-string for keyword-item
  189.       ((symbol? item) (display item) item) ;symbol for syntactic-closures
  190.       ((boolean? item) (display item) item) ;symbol for syntactic-closures
  191.       (else (write item) (impl-error "unknown item" item))))
  192.  
  193. ;;;; Syntactic Closures
  194.  
  195. (define syntactic-closure-type
  196.   (make-record-type "syntactic-closure" '(ENVIRONMENT FREE-NAMES FORM)))
  197.  
  198. (define make-syntactic-closure
  199.   (record-constructor syntactic-closure-type '(ENVIRONMENT FREE-NAMES FORM)))
  200.  
  201. (define syntactic-closure?
  202.   (record-predicate syntactic-closure-type))
  203.  
  204. (define syntactic-closure/environment
  205.   (record-accessor syntactic-closure-type 'ENVIRONMENT))
  206.  
  207. (define syntactic-closure/free-names
  208.   (record-accessor syntactic-closure-type 'FREE-NAMES))
  209.  
  210. (define syntactic-closure/form
  211.   (record-accessor syntactic-closure-type 'FORM))
  212.  
  213. (define (make-syntactic-closure-list environment free-names forms)
  214.   (map (lambda (form) (make-syntactic-closure environment free-names form))
  215.        forms))
  216.  
  217. (define (strip-syntactic-closures object)
  218.   (cond ((syntactic-closure? object)
  219.      (strip-syntactic-closures (syntactic-closure/form object)))
  220.     ((pair? object)
  221.      (cons (strip-syntactic-closures (car object))
  222.            (strip-syntactic-closures (cdr object))))
  223.     ((vector? object)
  224.      (let ((length (vector-length object)))
  225.        (let ((result (make-vector length)))
  226.          (do ((i 0 (+ i 1)))
  227.          ((= i length))
  228.            (vector-set! result i
  229.                 (strip-syntactic-closures (vector-ref object i))))
  230.          result)))
  231.     (else
  232.      object)))
  233.  
  234. (define (identifier? object)
  235.   (or (symbol? object)
  236.       (synthetic-identifier? object)))
  237.  
  238. (define (synthetic-identifier? object)
  239.   (and (syntactic-closure? object)
  240.        (identifier? (syntactic-closure/form object))))
  241.  
  242. (define (identifier->symbol identifier)
  243.   (cond ((symbol? identifier)
  244.      identifier)
  245.     ((synthetic-identifier? identifier)
  246.      (identifier->symbol (syntactic-closure/form identifier)))
  247.     (else
  248.      (impl-error "not an identifier" identifier))))
  249.  
  250. (define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
  251.   (let ((item-1 (syntactic-environment/lookup environment-1 identifier-1))
  252.     (item-2 (syntactic-environment/lookup environment-2 identifier-2)))
  253.     (or (eq? item-1 item-2)
  254.     ;; This is necessary because an identifier that is not
  255.     ;; explicitly bound by an environment is mapped to a variable
  256.     ;; item, and the variable items are not cached.  Therefore
  257.     ;; two references to the same variable result in two
  258.     ;; different variable items.
  259.     (and (variable-item? item-1)
  260.          (variable-item? item-2)
  261.          (eq? (variable-item/name item-1)
  262.           (variable-item/name item-2))))))
  263.  
  264. ;;;; Syntactic Environments
  265.  
  266. (define syntactic-environment-type
  267.   (make-record-type
  268.    "syntactic-environment"
  269.    '(PARENT
  270.      LOOKUP-OPERATION
  271.      RENAME-OPERATION
  272.      DEFINE-OPERATION
  273.      BINDINGS-OPERATION)))
  274.  
  275. (define make-syntactic-environment
  276.   (record-constructor syntactic-environment-type
  277.               '(PARENT
  278.             LOOKUP-OPERATION
  279.             RENAME-OPERATION
  280.             DEFINE-OPERATION
  281.             BINDINGS-OPERATION)))
  282.  
  283. (define syntactic-environment?
  284.   (record-predicate syntactic-environment-type))
  285.  
  286. (define syntactic-environment/parent
  287.   (record-accessor syntactic-environment-type 'PARENT))
  288.  
  289. (define syntactic-environment/lookup-operation
  290.   (record-accessor syntactic-environment-type 'LOOKUP-OPERATION))
  291.  
  292. (define (syntactic-environment/assign! environment name item)
  293.   (let ((binding
  294.      ((syntactic-environment/lookup-operation environment) name)))
  295.     (if binding
  296.     (set-cdr! binding item)
  297.     (impl-error "can't assign unbound identifier" name))))
  298.  
  299. (define syntactic-environment/rename-operation
  300.   (record-accessor syntactic-environment-type 'RENAME-OPERATION))
  301.  
  302. (define (syntactic-environment/rename environment name)
  303.   ((syntactic-environment/rename-operation environment) name))
  304.  
  305. (define syntactic-environment/define!
  306.   (let ((accessor
  307.      (record-accessor syntactic-environment-type 'DEFINE-OPERATION)))
  308.     (lambda (environment name item)
  309.       ((accessor environment) name item))))
  310.  
  311. (define syntactic-environment/bindings
  312.   (let ((accessor
  313.      (record-accessor syntactic-environment-type 'BINDINGS-OPERATION)))
  314.     (lambda (environment)
  315.       ((accessor environment)))))
  316.  
  317. (define (syntactic-environment/lookup environment name)
  318.   (let ((binding
  319.      ((syntactic-environment/lookup-operation environment) name)))
  320.     (cond (binding
  321.        (let ((item (cdr binding)))
  322.          (if (reserved-name-item? item)
  323.          (syntax-error "premature reference to reserved name"
  324.                    name)
  325.          item)))
  326.       ((symbol? name)
  327.        (make-variable-item name))
  328.       ((synthetic-identifier? name)
  329.        (syntactic-environment/lookup (syntactic-closure/environment name)
  330.                      (syntactic-closure/form name)))
  331.       (else
  332.        (impl-error "not an identifier" name)))))
  333.  
  334. (define root-syntactic-environment
  335.   (make-syntactic-environment
  336.    #f
  337.    (lambda (name)
  338.      name
  339.      #f)
  340.    (lambda (name)
  341.      name)
  342.    (lambda (name item)
  343.      (impl-error "can't bind name in root syntactic environment" name item))
  344.    (lambda ()
  345.      '())))
  346.  
  347. (define null-syntactic-environment
  348.   (make-syntactic-environment
  349.    #f
  350.    (lambda (name)
  351.      (impl-error "can't lookup name in null syntactic environment" name))
  352.    (lambda (name)
  353.      (impl-error "can't rename name in null syntactic environment" name))
  354.    (lambda (name item)
  355.      (impl-error "can't bind name in null syntactic environment" name item))
  356.    (lambda ()
  357.      '())))
  358.  
  359. (define (top-level-syntactic-environment parent)
  360.   (let ((bound '()))
  361.     (make-syntactic-environment
  362.      parent
  363.      (let ((parent-lookup (syntactic-environment/lookup-operation parent)))
  364.        (lambda (name)
  365.      (or (assq name bound)
  366.          (parent-lookup name))))
  367.      (lambda (name)
  368.        name)
  369.      (lambda (name item)
  370.        (let ((binding (assq name bound)))
  371.      (if binding
  372.          (set-cdr! binding item)
  373.          (set! bound (cons (cons name item) bound)))))
  374.      (lambda ()
  375.        (alist-copy bound)))))
  376.  
  377. (define (internal-syntactic-environment parent)
  378.   (let ((bound '())
  379.     (free '()))
  380.     (make-syntactic-environment
  381.      parent
  382.      (let ((parent-lookup (syntactic-environment/lookup-operation parent)))
  383.        (lambda (name)
  384.      (or (assq name bound)
  385.          (assq name free)
  386.          (let ((binding (parent-lookup name)))
  387.            (if binding (set! free (cons binding free)))
  388.            binding))))
  389.      (make-name-generator)
  390.      (lambda (name item)
  391.        (cond ((assq name bound)
  392.           =>
  393.           (lambda (association)
  394.         (if (and (reserved-name-item? (cdr association))
  395.              (not (reserved-name-item? item)))
  396.             (set-cdr! association item)
  397.             (impl-error "can't redefine name; already bound" name))))
  398.          ((assq name free)
  399.           (if (reserved-name-item? item)
  400.           (syntax-error "premature reference to reserved name"
  401.                 name)
  402.           (impl-error "can't define name; already free" name)))
  403.          (else
  404.           (set! bound (cons (cons name item) bound)))))
  405.      (lambda ()
  406.        (alist-copy bound)))))
  407.  
  408. (define (filter-syntactic-environment names names-env else-env)
  409.   (if (or (null? names)
  410.       (eq? names-env else-env))
  411.       else-env
  412.       (let ((make-operation
  413.          (lambda (get-operation)
  414.            (let ((names-operation (get-operation names-env))
  415.              (else-operation (get-operation else-env)))
  416.          (lambda (name)
  417.            ((if (memq name names) names-operation else-operation)
  418.             name))))))
  419.     (make-syntactic-environment
  420.      else-env
  421.      (make-operation syntactic-environment/lookup-operation)
  422.      (make-operation syntactic-environment/rename-operation)
  423.      (lambda (name item)
  424.        (impl-error "can't bind name in filtered syntactic environment"
  425.                name item))
  426.      (lambda ()
  427.        (map (lambda (name)
  428.           (cons name
  429.             (syntactic-environment/lookup names-env name)))
  430.         names))))))
  431.  
  432. ;;;; Items
  433.  
  434. ;;; Reserved name items do not represent any form, but instead are
  435. ;;; used to reserve a particular name in a syntactic environment.  If
  436. ;;; the classifier refers to a reserved name, a syntax error is
  437. ;;; signalled.  This is used in the implementation of LETREC-SYNTAX
  438. ;;; to signal a meaningful error when one of the <init>s refers to
  439. ;;; one of the names being bound.
  440.  
  441. (define reserved-name-item-type
  442.   (make-record-type "reserved-name-item" '()))
  443.  
  444. (define make-reserved-name-item
  445.   (record-constructor reserved-name-item-type '()))
  446.  
  447. (define reserved-name-item?
  448.   (record-predicate reserved-name-item-type))
  449.  
  450. ;;; Keyword items represent macro keywords.
  451.  
  452. (define keyword-item-type
  453.   (make-record-type "keyword-item" '(CLASSIFIER NAME)))
  454. ;  (make-record-type "keyword-item" '(CLASSIFIER)))
  455.  
  456. (define make-keyword-item
  457. ;  (lambda (cl) (display "make-keyword-item:") (write cl) (newline)
  458. ;    ((record-constructor keyword-item-type '(CLASSIFIER)) cl)))
  459.   (record-constructor keyword-item-type '(CLASSIFIER NAME)))
  460. ;  (record-constructor keyword-item-type '(CLASSIFIER)))
  461.  
  462. (define keyword-item?
  463.   (record-predicate keyword-item-type))
  464.  
  465. (define keyword-item/classifier
  466.   (record-accessor keyword-item-type 'CLASSIFIER))
  467.  
  468. (define keyword-item/name
  469.   (record-accessor keyword-item-type 'NAME))
  470.  
  471. ;;; Variable items represent run-time variables.
  472.  
  473. (define variable-item-type
  474.   (make-record-type "variable-item" '(NAME)))
  475.  
  476. (define make-variable-item
  477.   (record-constructor variable-item-type '(NAME)))
  478.  
  479. (define variable-item?
  480.   (record-predicate variable-item-type))
  481.  
  482. (define variable-item/name
  483.   (record-accessor variable-item-type 'NAME))
  484.  
  485. ;;; Expression items represent any kind of expression other than a
  486. ;;; run-time variable or a sequence.  The ANNOTATION field is used to
  487. ;;; make expression items that can appear in non-expression contexts
  488. ;;; (for example, this could be used in the implementation of SETF).
  489.  
  490. (define expression-item-type
  491.   (make-record-type "expression-item" '(COMPILER ANNOTATION)))
  492.  
  493. (define make-expression-item
  494.   (record-constructor expression-item-type '(COMPILER ANNOTATION)))
  495.  
  496. (define expression-item?
  497.   (record-predicate expression-item-type))
  498.  
  499. (define expression-item/compiler
  500.   (record-accessor expression-item-type 'COMPILER))
  501.  
  502. (define expression-item/annotation
  503.   (record-accessor expression-item-type 'ANNOTATION))
  504.  
  505. ;;; Body items represent sequences (e.g. BEGIN).
  506.  
  507. (define body-item-type
  508.   (make-record-type "body-item" '(COMPONENTS)))
  509.  
  510. (define make-body-item
  511.   (record-constructor body-item-type '(COMPONENTS)))
  512.  
  513. (define body-item?
  514.   (record-predicate body-item-type))
  515.  
  516. (define body-item/components
  517.   (record-accessor body-item-type 'COMPONENTS))
  518.  
  519. ;;; Definition items represent definitions, whether top-level or
  520. ;;; internal, keyword or variable.
  521.  
  522. (define definition-item-type
  523.   (make-record-type "definition-item" '(BINDING-THEORY NAME VALUE)))
  524.  
  525. (define make-definition-item
  526.   (record-constructor definition-item-type '(BINDING-THEORY NAME VALUE)))
  527.  
  528. (define definition-item?
  529.   (record-predicate definition-item-type))
  530.  
  531. (define definition-item/binding-theory
  532.   (record-accessor definition-item-type 'BINDING-THEORY))
  533.  
  534. (define definition-item/name
  535.   (record-accessor definition-item-type 'NAME))
  536.  
  537. (define definition-item/value
  538.   (record-accessor definition-item-type 'VALUE))
  539.  
  540. (define (bind-definition-item! environment item)
  541.   ((definition-item/binding-theory item)
  542.    environment
  543.    (definition-item/name item)
  544.    (promise:force (definition-item/value item))))
  545.  
  546. (define (syntactic-binding-theory environment name item)
  547.   (if (or (keyword-item? item)
  548.       (variable-item? item))
  549.       (begin
  550.     (syntactic-environment/define! environment name item)
  551.     #f)
  552.       (syntax-error "syntactic binding value must be a keyword or a variable"
  553.             item)))
  554.  
  555. (define (variable-binding-theory environment name item)
  556.   ;; If ITEM isn't a valid expression, an error will be signalled by
  557.   ;; COMPILE-ITEM/EXPRESSION later.
  558.   (cons (bind-variable! environment name) item))
  559.  
  560. (define (overloaded-binding-theory environment name item)
  561.   (if (keyword-item? item)
  562.       (begin
  563.     (syntactic-environment/define! environment name item)
  564.     #f)
  565.       (cons (bind-variable! environment name) item)))
  566.  
  567. ;;;; Classifiers, Compilers, Expanders
  568.  
  569. (define (sc-expander->classifier expander keyword-environment)
  570.   (lambda (form environment definition-environment)
  571.     (classify/form (expander form environment)
  572.            keyword-environment
  573.            definition-environment)))
  574.  
  575. (define (er-expander->classifier expander keyword-environment)
  576.   (sc-expander->classifier (er->sc-expander expander) keyword-environment))
  577.  
  578. (define (er->sc-expander expander)
  579.   (lambda (form environment)
  580.     (capture-syntactic-environment
  581.      (lambda (keyword-environment)
  582.        (make-syntactic-closure
  583.     environment '()
  584.     (expander form
  585.           (let ((renames '()))
  586.             (lambda (identifier)
  587.               (let ((association (assq identifier renames)))
  588.             (if association
  589.                 (cdr association)
  590.                 (let ((rename
  591.                    (make-syntactic-closure
  592.                     keyword-environment
  593.                     '()
  594.                     identifier)))
  595.                   (set! renames
  596.                     (cons (cons identifier rename)
  597.                       renames))
  598.                   rename)))))
  599.           (lambda (x y)
  600.             (identifier=? environment x
  601.                   environment y))))))))
  602.  
  603. (define (classifier->keyword classifier)
  604.   (make-syntactic-closure
  605.    (let ((environment
  606.       (internal-syntactic-environment null-syntactic-environment)))
  607.      (syntactic-environment/define! environment
  608.                     'KEYWORD
  609.                     (make-keyword-item classifier "c->k"))
  610.      environment)
  611.    '()
  612.    'KEYWORD))
  613.  
  614. (define (compiler->keyword compiler)
  615.   (classifier->keyword (compiler->classifier compiler)))
  616.  
  617. (define (classifier->form classifier)
  618.   `(,(classifier->keyword classifier)))
  619.  
  620. (define (compiler->form compiler)
  621.   (classifier->form (compiler->classifier compiler)))
  622.  
  623. (define (compiler->classifier compiler)
  624.   (lambda (form environment definition-environment)
  625.     definition-environment        ;ignore
  626.     (make-expression-item
  627.      (lambda () (compiler form environment)) form)))
  628.  
  629. ;;;; Macrologies
  630. ;;;  A macrology is a procedure that accepts a syntactic environment
  631. ;;;  as an argument, producing a new syntactic environment that is an
  632. ;;;  extension of the argument.
  633.  
  634. (define (make-primitive-macrology generate-definitions)
  635.   (lambda (base-environment)
  636.     (let ((environment (top-level-syntactic-environment base-environment)))
  637.       (let ((define-classifier
  638.           (lambda (keyword classifier)
  639.         (syntactic-environment/define!
  640.          environment
  641.          keyword
  642.          (make-keyword-item classifier keyword)))))
  643.     (generate-definitions
  644.      define-classifier
  645.      (lambda (keyword compiler)
  646.        (define-classifier keyword (compiler->classifier compiler)))))
  647.       environment)))
  648.  
  649. (define (make-expander-macrology object->classifier generate-definitions)
  650.   (lambda (base-environment)
  651.     (let ((environment (top-level-syntactic-environment base-environment)))
  652.       (generate-definitions
  653.        (lambda (keyword object)
  654.      (syntactic-environment/define!
  655.       environment
  656.       keyword
  657.       (make-keyword-item (object->classifier object environment) keyword)))
  658.        base-environment)
  659.       environment)))
  660.  
  661. (define (make-sc-expander-macrology generate-definitions)
  662.   (make-expander-macrology sc-expander->classifier generate-definitions))
  663.  
  664. (define (make-er-expander-macrology generate-definitions)
  665.   (make-expander-macrology er-expander->classifier generate-definitions))
  666.  
  667. (define (compose-macrologies . macrologies)
  668.   (lambda (environment)
  669.     (do ((macrologies macrologies (cdr macrologies))
  670.      (environment environment ((car macrologies) environment)))
  671.     ((null? macrologies) environment))))
  672.  
  673. ;;;; Utilities
  674.  
  675. (define (bind-variable! environment name)
  676.   (let ((rename (syntactic-environment/rename environment name)))
  677.     (syntactic-environment/define! environment
  678.                    name
  679.                    (make-variable-item rename))
  680.     rename))
  681.  
  682. (define (reserve-names! names environment)
  683.   (let ((item (make-reserved-name-item)))
  684.     (for-each (lambda (name)
  685.         (syntactic-environment/define! environment name item))
  686.           names)))
  687.  
  688. (define (capture-syntactic-environment expander)
  689.   (classifier->form
  690.    (lambda (form environment definition-environment)
  691.      form                ;ignore
  692.      (classify/form (expander environment)
  693.             environment
  694.             definition-environment))))
  695.  
  696. (define (unspecific-expression)
  697.   (compiler->form
  698.    (lambda (form environment)
  699.      form environment            ;ignore
  700.      (output/unspecific))))
  701.  
  702. (define (unassigned-expression)
  703.   (compiler->form
  704.    (lambda (form environment)
  705.      form environment            ;ignore
  706.      (output/unassigned))))
  707.  
  708. (define (syntax-quote expression)
  709.   `(,(compiler->keyword
  710.       (lambda (form environment)
  711.     environment            ;ignore
  712.     (syntax-check '(KEYWORD DATUM) form)
  713.     (output/literal-quoted (cadr form))))
  714.     ,expression))
  715.  
  716. (define (flatten-body-items items)
  717.   (append-map item->list items))
  718.  
  719. (define (item->list item)
  720.   (if (body-item? item)
  721.       (flatten-body-items (body-item/components item))
  722.       (list item)))
  723.  
  724. (define (output/let names values body)
  725.   (if (null? names)
  726.       body
  727.       (output/combination (output/lambda names body) values)))
  728.  
  729. (define (output/letrec names values body)
  730.   (if (null? names)
  731.       body
  732.       (output/let
  733.        names
  734.        (map (lambda (name) name (output/unassigned)) names)
  735.        (output/sequence
  736.     (list (if (null? (cdr names))
  737.           (output/assignment (car names) (car values))
  738.           (let ((temps (map (make-name-generator) names)))
  739.             (output/let
  740.              temps
  741.              values
  742.              (output/sequence
  743.               (map output/assignment names temps)))))
  744.           body)))))
  745.  
  746. (define (output/top-level-sequence expressions)
  747.   (if (null? expressions)
  748.       (output/unspecific)
  749.       (output/sequence expressions)))
  750.